;;########################################################################
;; workmap2.lsp 
;; connect-icons, locate-icons
;; Copyright (c) 1992-2002 by Forrest W. Young
;;########################################################################  


(defmeth iconmap-proto :resize ()
  (call-next-method)
  (apply #'send self :content-rect 4 40 (- (send self :size) '(0 40)))
  (apply #'send self :clip-rect (send self :content-rect))
  (send self :adjust-canvas-size))

                
(defmeth iconmap-proto :locate-icon 
              (to-icon-type  all-x all-y &optional from-icon)
"Args: to-icon-type all-x all-y &optional from-icon
Locates icon of to-icon-type below FROM-ICON's location, if specified, or below workmap origin otherwise, given ALL-X ALL-Y (location of all visible icons)."
  (let ((x-origin 34) ;min-y min-x define orgin of map to be below toolbar
        (y-origin (+ 28 (send self :text-ascent) 
                   (send self :text-descent))))
    (cond
      ((or (= 0 (send self :num-icons)) ;virgin workmap
           (not (and all-x all-y))) ;used workmap with all icons deleted
       (list x-origin y-origin))
      (t
       (let* ((x-min x-origin)
              (icon-type to-icon-type)
              (from-icon-type (if from-icon (send from-icon :icon-type) 1))
              (x-step 88)
              (y-step 58); should be even 
              (icon-height  46)
              (icon-y-gap (- y-step icon-height))
              (min-distance-x x-step)
              (min-distance-y y-step)
              (x-origin (if from-icon
                            (send from-icon :x)
                            x-origin))
              (y-origin (if from-icon ;when connecting, start below from icon
                            (+ y-step (send from-icon :y))
                            y-origin)) 
              (to-icon-width   (if (member to-icon-type '(1 3 4 5)) 25 45))
              (from-icon-width (if from-icon
                                   (if (member (send from-icon :icon-type) '(1 3 4 5))
                                       25 45)
                                   to-icon-width))
              (icon-locx-adjust (if from-icon 
                                    (round (* 1/2 (- from-icon-width to-icon-width))) 0))
              (icon-locy-1st-adjust (if from-icon 0 -1)) ; 0 -1 BEST
              (icon-locy-2nd-adjust (if from-icon 0 0)) ; -1 0 BEST
              (min-distance-y (+ y-step icon-locy-1st-adjust))
              (window-width   (max (first (send *workmap* :size))
                                   (send *workmap* :canvas-width)))
              (window-width   (if  (< window-width  0) (first  (screen-size)) window-width))
             ; (window-width   (first (screen-size)))
              (window-height  (max (second (send *workmap* :size))
                                   (send *workmap* :canvas-height)))
              (window-height  (if  (< window-height 0) (second (screen-size)) window-height))
              (num-x-grids    (1+ (floor (/ (- window-width  x-min) x-step))))
              (num-y-grids    (1+ (floor (/ (- window-height y-origin) y-step))))
              (x-max (- window-width (max from-icon-width to-icon-width)))
              (iflag)
              (best-x x-origin) (best-y y-origin)
              (x-i x-origin)
              (y-i y-origin)
              ) 
             (dotimes 
              (i num-y-grids)
              (when iflag (return))
              (setf y-i (+ y-origin (* i y-step)))
              (dotimes 
               (j num-x-grids)
               (cond	
                 (from-icon
                  (cond
                    ((= 0    j) (setf c  0))
                    ((odd-p  j) (setf c  1))
                    ((even-p j) (setf c -1)))
                  (setf x-offset (* c (ceiling (/ j 2)) x-step))
                  ;(PRINT (LIST "xmin value xmax" x-min (+ x-origin x-offset) x-max))
                  (unless (<= x-min (+ x-origin x-offset) x-max)
                          (setf x-offset (* -1 x-offset)))
                  (setf x-i (+ x-origin x-offset)))
                 (t (setf x-i (+ x-origin (* j x-step)))))
               (setf nearest-xy (send self :nearest-city-block-neighbor
                                      all-x x-i all-y y-i))
               ;(print (list x-i y-i nearest-xy))
               (when (and (or (>= (first  nearest-xy) min-distance-x)
                              (>= (second nearest-xy) min-distance-y))
                          (not iflag))
                     (setf iflag t)
                     (setf best-x x-i)
                     (setf best-y y-i)
                     (return))))
        ; (send self :check-scroll-bars)
         (when iflag
               (setf x-i best-x)
               (setf y-i best-y))
         ;(print (list "XI DIFF "x-i icon-loc-adjust ))
         (setf x-i (+ x-i icon-locx-adjust))
         (setf y-i (- y-i icon-locy-2nd-adjust))
         (send self :postpone-redraw nil)
         (send self :check-scroll-bars)
         ;(print (list "adjust x" x-i y-i))
         (list x-i y-i))))))


(defmeth iconmap-proto :add-connected-icon(from-icon-number title icon-type 
                  &optional data-type  
                  &key array (x-offset 0) (y-offset 0) (object nil))
  (let* ((from-icon (select (send self :icon-list) from-icon-number))
         (to-icon-type icon-type)
         (all-x (if (send self :deleted?)
                    (select  (send self :x) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :x)))
         (all-y (if (send self :deleted?)
                    (select  (send self :y) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :y)))
         (to-icon-number)
         )
    (setf to-xy (send self :locate-icon to-icon-type all-x all-y from-icon))
    (setf to-x (first  to-xy))
    (setf to-y (second to-xy))
    (setf to-icon (send self :add-icon self to-x to-y title 
                        icon-type data-type array :object object))
    (setf to-icon-number (- (send self :num-icons) 1))
    (send from-icon :icon-state "normal")
    (send from-icon :turn-title-off)
    (send from-icon :draw-title "normal")
    (send from-icon :show-icon "normal")
    (send self :connect-icons from-icon-number to-icon-number :new t)
    (send to-icon :show-icon "selected")
    to-icon))

(defmeth iconmap-proto :nearest-neighbor (all-y to-y all-x to-x)
  (send self :nearest-city-block-neighbor all-x to-x all-y to-y))

(defmeth iconmap-proto :nearest-city-block-neighbor (all-x x all-y y)
  (let* ((x-distances (abs (- all-x x)))
         (y-distances (abs (- all-y y)))
         (city-block-distances (+ x-distances y-distances))
         (least-city-block-distance (min city-block-distances))
         (which (position least-city-block-distance city-block-distances))
         (x-distance (select x-distances which))
         (y-distance (select y-distances which)))
    (list x-distance y-distance)))

(defmeth iconmap-proto :connect-icons (icon-number-out icon-number-in &key new)
  (let* ((icon-out (select (send self :icon-list) icon-number-out))
         (x-out (send icon-out :x))
         (y-out (send icon-out :y))
         (icon-in  (select (send self :icon-list) icon-number-in))
         (x-in  (send icon-in  :x))
         (y-in  (send icon-in  :y))
         (center-out (floor (/ (send icon-out :width) 2)))
         (center-in  (floor (/ (send icon-in  :width) 2)))
         (below-out  (send icon-out :height))
         (below-in   (send icon-in  :height))
         (b 16); 1 b+c=length horizontal line above/below icon
         (c 7) ;length of vertical line coming into lower icon 7
         (C 7)
         (c+ (+ c 0))
         (d 17) ;length of vertical line coming out of upper icon 17,16 10,19
         (d 17)
         (e 30) ;19
         (dc (send self :draw-color))
         (horizontal-in  (+ center-in c b)) 
         (horizontal-out (+ center-out c b)) 
         (line-start-x (+ x-out center-out))
         (line-start-y (+ y-out below-out))
         (line-end-x (+ x-in center-in))
         (line-end-y y-in)
         (line-mid-segment-x nil)
         (line-mid-segment-y nil)
         (ifl nil) (connections-to-me) (to-list)
         (line-list (list (list line-start-x line-start-y)))) 
    (send self :draw-color 'black)
    (cond 
      ((and (= line-start-x line-end-x) ;when in icon directly below out icon
            (< line-start-y line-end-y))
       (setf line-list (append line-list (list 
                              (list 0 (- line-end-y line-start-y 1))))))
      (t ;in not directly below out
         (setf line-list (append line-list (list (list 0 d))))
         (cond
           ((< line-start-y line-end-y) ;in below out, but not directly
            (setf line-list (append line-list (list 
                            (list (- line-end-x line-start-x)
                                  (- line-end-y c+ (+ line-start-y d)))
                            (list 0 c)))))
           (t ;in above out
              (when (> line-start-x line-end-x)  ;in right of out
                    (setf horizontal-out (- horizontal-out))
                    (setf horizontal-in  (- horizontal-in)))
              (setf line-list (append line-list (list
                              (list horizontal-out 0))))
              (setf line-mid-segment-x (- (- line-end-x horizontal-in) 
                                          (+ line-start-x horizontal-out)))
              (setf line-mid-segment-y (- (- line-end-y c+)
                                          (+ line-start-y d))); 10
              (when (> (* line-mid-segment-x (- line-start-x line-end-x)) 0)
                    (setf ifl t)
                    (setf line-mid-segment-x 
                          (+ line-mid-segment-x (* 2 horizontal-in)))
                    (setf horizontal-in (- horizontal-in))
                    (setf line-mid-segment-y 
                          (+ line-mid-segment-y below-in e)))
              (setf line-list (append line-list (list 
                              (list line-mid-segment-x line-mid-segment-y))))
              (when ifl
                    (setf line-list (append line-list (list 
                                    (list 0 (- 0 below-in e))))))
              (setf line-list (append line-list (list
                              (list horizontal-in 0)
                              (list 0 c)))))))) 
    (setf line-list (append line-list (list '(-4 -4) '(8 0) '(-4 4))))
    (send self :frame-poly line-list nil) 
    (when new 
          (setf connections-to-me 
                (select (send self :connections-to-me) icon-number-in))
          (setf (select (send self :connections-to-me) icon-number-in)
                (remove nil (add-element-to-list connections-to-me icon-number-out)))
          (setf to-list (select (send self :connection-list) icon-number-out))
          (setf to-list (remove 'nil (combine to-list icon-number-in)))
          (setf (select (send self :connection-list) icon-number-out)
                to-list))
    (send self :draw-color dc)
    line-list))


(defmeth iconmap-proto :redraw-connections (i)
(print "workmap2.lsp :redraw-connections")
  (when *vista*
  (when (not (send self :postpone-redraw))
  (when (send *vista* :ready-to-redraw self)  
   (when (send self :gui)
     (let* ((n    (send self :num-icons))
            (icon-list (send self :icon-list))
            (redraw-order (send self :redraw-order))
            (connection-list (send self :connection-list))
            (connections-i) (k 0)
            (bc (send self :back-color))
            (dc (send self :draw-color))
            (icon)
            (y-vals (send self :y))
            (logo-at-top nil)
            (has-v-scroll (send self :has-v-scroll))
            (toolbar-length (send self :toolbar-length))
            )
       (when (> (first (send self :size)) (+ toolbar-length (if has-v-scroll 140 124)))
          (setf logo-at-top t))
       (when (and icon-list (not connection-list)) 
             (setf connection-list '((nil)))
             (send self :connection-list connection-list))
       (when (and (> n 0) icon-list)
             (setf connections-i 
                   (select connection-list (select redraw-order i)))
             (when (select connections-i 0)
                   (dotimes (j (length connections-i))
                            (from-icon (select redraw-order i))
                            (to-icon (select icon-list (select connections-i j)))
                            (send self :connect-icons (select redraw-order i)
                                  (select connections-i j)) 
                           ))
             )
         (send self :draw-color dc)
         (send self :back-color bc)
         )))
        (send *vista* :finished-redraw self)
        )))

(defmeth iconmap-proto :add-connected-icon(from-icon-number title icon-type 
                  &optional data-type  
                  &key array (x-offset 0) (y-offset 0) (object nil))
  (let* ((from-icon (select (send self :icon-list) from-icon-number))
         (from-x (send from-icon :x))
         (from-y (send from-icon :y))
         (from-icon-type (send from-icon :icon-type))
         (icon-height (send from-icon :height))
         (icon-width 50)
         (to-icon nil)
         (to-icon-type icon-type)
         (to-icon-number nil)
         (to-x nil)
         (to-y nil)
         (to-xy)
      ;   (iflag nil)
         (all-x (if (send self :deleted?)
                    (select  (send self :x) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :x)))
         (all-y (if (send self :deleted?)
                    (select  (send self :y) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :y)))
         (vertical-seperation   23);was 19 28
         (horizontal-seperation (if (send self :icon-spacing?) 94 74))
         ;recently, 94, long time was 84
         (min-distance (+ icon-height vertical-seperation)) ;50
 
         (vertical-zig-zag      (if (send self :zig-zag) 13 0)); was 10
         (num-connections (length 
                           (select (send self :connection-list) from-icon-number)))
         (window-width (first (send self :size)))
         (x-offset) (y-offset) (nearest-neighbor)
         )
    (when (and (= num-connections 1) 
               (not (select 
                     (select (send self :connection-list) from-icon-number)
                     0)))
          (setf num-connections 0))
    (setf x-offset (send self :find-x-offset 
                         num-connections horizontal-seperation 
                         icon-type from-icon-type))
    (setf y-offset (+ icon-height vertical-seperation))
    (setf to-x (+ from-x x-offset))
    (setf to-y (+ from-y y-offset))
    (setf nearest-neighbor
          (send self :nearest-neighbor all-y to-y all-x to-x)) 
    (when (or (> (+ to-x icon-width) window-width)
              (< nearest-neighbor min-distance))

          (setf to-xy (send self :locate-icon to-icon-type  all-x all-y from-icon))
          (setf to-x (first to-xy))
          (setf to-y (second to-xy))

          )
    (when (/= (/ num-connections 2) (floor (/ num-connections 2))) 
          (setf to-y (+ to-y vertical-zig-zag)))
    (setf to-icon (send self :add-icon self to-x to-y title 
                        icon-type data-type array :object object))
    (setf to-icon-number (- (send self :num-icons) 1))
    (send from-icon :icon-state "normal")
    (send from-icon :turn-title-off)
    (send from-icon :draw-title "normal")
    (send from-icon :show-icon "normal")


    (send self :connect-icons from-icon-number to-icon-number :new t)
    (send to-icon :show-icon "selected")
    to-icon
    ))


(defmeth iconmap-proto :adjust-canvas-size ()
  (when (and *vista*
             *vista-exists* 
             (not (send self :postpone-redraw))
             (send *vista* :ready-to-redraw self)  
             (send self :gui))
        (when (send self :x)
              (let* ((mc (^ 2 12)); maxcanvas size in both direction
                     ; (max window hardware is (^ 2 16) on my machine)
                     (border 70)
                     (max-x)
                     (max-y)
                     (can-w (send self :canvas-width))
                     (can-h (send self :canvas-height))
                     (window-w (first (send self :size)))
                     (window-h (second (send self :size))))
                (send self :fix-xy-values (send self :x) (send self :y) mc)
                (setf max-x (+ border (max (send self :x))))
                (setf max-y (+ border (max (send self :y))))
                ;  (when (> max-x mc) (setf max-x (- max-x (* (floor (/ max-x mc)) mc))))
                ;  (when (> max-y mc) (setf max-y (- max-y (* (floor (/ max-y mc)) mc))))
                ;(PRINT (LIST "MAX X,Y = " MAX-x MAX-y "CANVAS W,H = " CAN-W CAN-H "SIZE = " (SEND SELF :SIze)))
                (if (< window-w max-x)
                    (send self :has-h-scroll max-x)
                    (send self :has-h-scroll nil))
                (if (< window-h max-y)
                    (send self :has-v-scroll max-y)
                    (send self :has-v-scroll nil))
                ))
        (list (send self :canvas-width) (send self :canvas-height))))

(defmeth iconmap-proto :fix-xy-values (x y mc)
  (let ((ic-list (send self :icon-list))
        );maxcanvas size in both direction...(max window hardware is (^ 2 16) on my machine)
    (when (< (min x) 20)
          (send self :x
                (mapcar #'(lambda (x i) 
                            (when (< x 20) 
                                  (send (select ic-list  i) :x 20))
                            (if (< x 20) 20 x))
                        x (iseq (length x)))))
        
    (when (< (min y) 42)
          (send self :y
                (mapcar #'(lambda (y i) 
                            (when (< y 42) 
                                  (send (select ic-list  i)
                                        :y 42))
                            (if (< y 42) 42 y))
                        y (iseq (length y)))))
        
   (when (> (+ (max x) 100) mc)
         (send self :x
               (mapcar #'(lambda (x i) 
                           (when (> (+ x 100) mc)
                                 (send (select ic-list i)
                                       :x (- x  -100 (* (floor (/ x mc)) mc))))
                           (setf x (- x  -100 (* (floor (/ x mc)) mc)))) 
                       x (iseq (length x)))))
        
    (when (> (+ (max y) 100) mc)
          (send self :y
                (mapcar #'(lambda (y i) 
                            (when (> (+ y 100) mc)
                                  (send (select ic-list i)
                                        :y (- y  -100 (* (floor (/ y mc)) mc))))
                            (setf y (- y -100 (* (floor (/ y mc)) mc))))
                        y (iseq (length y)))))))